home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 050 / madtrb7.arc / PTOOL1.BOX < prev    next >
Text File  |  1985-01-01  |  58KB  |  1,596 lines
  1. { PTOOL1.BOX     Copyright 1985  R D Ostrander                   Version 1.0
  2.                                  Ostrander Data Services
  3.                                  5437 Honey Manor Dr
  4.                                  Indianapolis  IN  46241
  5.  
  6.  These Turbo Pascal functions and procedures are a combination of PTOOLDAT.INC
  7.  PTOOLENT.INC and PTOOLSCR.INC with Gregorian and Julian date (D & J) entry
  8.  options added to PTOOLENT and PTOOLSCR. See the individual subroutines for
  9.  details about each. These must be included together since the date checking
  10.  of PTOOLDAT is necessary for date field entries.
  11.  
  12.  This program has been placed in the Public Domain by the author and copies
  13.  may be freely made for non-commercial, demonstration, or evaluation purposes.
  14.  Use of these subroutines in a program for sale or for commercial purposes in
  15.  a place of business requires a $40 fee be paid to the author at the address
  16.  above.  Personal non-commercial users may also elect to pay the $40 fee to
  17.  encourage further development of this and similar programs. With payment you
  18.  will be able to receive update notices, diskettes and printed documentation
  19.  of this and other PTOOLs from Ostrander Data Services.
  20.  
  21.  PTOOL, and PTOOLxxx are Copyright Trademarks of Ostrander Data Services
  22.  
  23.  Turbo Pascal is a Copyright of Borland International Inc.                  }
  24.  
  25.  
  26. { PTOOLDAT portion of PTOOL1.BOX begins here ****************************** }
  27.  
  28.  
  29.  
  30. { Constants and Parameters Begin Here ************************************* }
  31.  
  32.  
  33. TYPE
  34.  
  35.      PTOOLDAT_Str_21   = String [21];                    {Gregorian Dates    }
  36.      PTOOLDAT_Str_3    = String [3];                     {Order of elements  }
  37.      PTOOLDAT_Str_9    = String [9];                     {Day of Week        }
  38.      PTOOLDAT_Elements = Array [1..3]  of String [21];   {Parsing elements   }
  39.      PTOOLDAT_Numbers  = Array [1..3]  of Integer;       {Parsing numbers    }
  40.      PTOOLDAT_Months   = Array [1..12] of String [9];    {Months Names       }
  41.      PTOOLDAT_Days     = Array [1..7]  of PTOOLDAT_Str_9;{Days of the Week   }
  42.  
  43.  
  44. CONST
  45.  
  46.    { Gregorian Date      A string expression of up to 21 characters.
  47.      --------------      example:  02/15/50  or  February 2, 1950
  48.  
  49.                          The order and style to display the elements
  50.                          (Month, Day, Year) are determined by the
  51.                          parameters below.
  52.  
  53.                          As an argument, the date is passed as a string
  54.                          expression with 3 elements in the same order as
  55.                          displayed separated by at least one of the
  56.                          characters  / - , . ' ; : ( ) · or a space.      }
  57.  
  58.                                            {    Gregorian Date parameters    }
  59.                                            {*********************************}
  60.  PTOOLDAT_G_YrDisp  : Byte        = 2;     { # of Display Chars for Year     }
  61.                                            {     2    = 50                   }
  62.                                            {     4    = 1950                 }
  63.  PTOOLDAT_G_MoDisp  : Byte        = 2;     { # of Display Chars for Month    }
  64.                                            {     2    = 02                   }
  65.                                            {     3    = Feb                  }
  66.                                            {     9    = February             }
  67.  PTOOLDAT_G_DaDisp  : Byte        = 2;     { # of Display Chars for Day      }
  68.                                            {     2    = 15                   }
  69.  PTOOLDAT_G_Order   : String [3]  = 'MDY'; { Order of Display                }
  70.                                            {     MDY  = 02 15 50             }
  71.  PTOOLDAT_G_Sep1    : String [3]  = '/';   { 1st Separation Character        }
  72.                                            {     /    = 02/15 50             }
  73.  PTOOLDAT_G_Sep2    : String [3]  = '/';   { 2nd Separation Character        }
  74.                                            {     /    = 02/15/50             }
  75.  PTOOLDAT_G_ZeroSup : Boolean     = True;  { Zero Suppress Display?          }
  76.                                            {     True =  2/15/50             }
  77.                                            {*********************************}
  78.  
  79.    { The 2nd Gregorian Date is used solely as input for
  80.      the conversion function PTDGtoG                    }
  81.  
  82.                                            {  2nd Gregorian Date parameters  }
  83.                                            {*********************************}
  84.  PTOOLDAT_G2_Order  : String [3]  = 'MDY'; { Order of Input                  }
  85.                                            {*********************************}
  86.  
  87.    { Julian Date      A Real number in either of three formats:
  88.      -----------      A = ANSI Date (YYDDD)  YY is the year within century
  89.                                             DDD is the day of the year
  90.                       B = ANSI Date (YYYYDDD) YYYY is the year
  91.                                               DDD  is the day of the year
  92.                       E = Elapsed days since January 1 of the base year below.
  93.                                Note that this may result in a negative number
  94.                                if the date is previous to the base year
  95.                           CAUTION - If the base year below is changed, this
  96.                                value becomes meaningless.
  97.  
  98.  
  99.  
  100.                                            {      Julian Date parameter      }
  101.                                            {*********************************}
  102.  PTOOLDAT_J_Type    : Char        = 'A';   { Julian Date Type                }
  103.                                            {     A    = ANSI Date (YYDDD)    }
  104.                                            {                      (50046)    }
  105.                                            {     B    = ANSI DATE (YYYYDDD)  }
  106.                                            {                      (1950046)  }
  107.                                            {     E    = Days since January   }
  108.                                            {                1st of base year }
  109.                                            {                      (7350)     }
  110.                                            {*********************************}
  111.  
  112.    { Short Date      An integer value representing the number of days since
  113.      ----------      January 1 of the base year below minus 32765. USE WITH
  114.                      CAUTION, dates earlier than the base year or later than
  115.                      179 years after the base year cannot be calculated (date
  116.                      returned is -32766). This date is useful for saving disk
  117.                      or table storage only - it must be changed back to
  118.                      another form to be used.
  119.  
  120.      Day of Week      A String expression of up to 9 characters
  121.      -----------      The format depends on the parameter below:
  122.  
  123.                 1 = 1      2      3       4         5        6      7
  124.                 3 = Sun    Mon    Tue     Wed       Thr      FrI    Sat
  125.                 9 = Sunday Monday Tuesday Wednesday Thursday Friday Saturday }
  126.  
  127.                                            {      Day of Week parameter      }
  128.                                            {*********************************}
  129.  PTOOLDAT_Day_Type  : Byte        = 3;     { Day of week Type                }
  130.                                            {     1    = 4                    }
  131.                                            {     2    = We                   }
  132.                                            {     3    = Wed                  }
  133.                                            {     9    = Wednesday            }
  134.                                            {*********************************}
  135.  
  136.     {Base Year        This is used for dates in Julian Type B format, for
  137.      ---------           conversion of dates entered without a century, and
  138.                          for Short format dates.
  139.                       If Base Year is 1930 then the year 50 will be calculated
  140.                          as 1950, the year 29 will be calculated as 2029.    }
  141.  
  142.  PTOOLDAT_BaseYear  : Integer     = 1930;
  143.  
  144. {*****   PTOOLDAT Internal usage fields follow:  *****}
  145.  
  146.  PTOOLDAT_Element   : PTOOLDAT_Elements = (' ', ' ', ' ');
  147.  PTOOLDAT_Number    : PTOOLDAT_Numbers  = (0, 0, 0);
  148.  PTOOLDAT_ElY       : String [9] = '         ';
  149.  PTOOLDAT_ElM       : String [9] = '         ';
  150.  PTOOLDAT_ElD       : String [9] = '         ';
  151.  PTOOLDAT_NumY      : Integer = 0;
  152.  PTOOLDAT_NumM      : Integer = 0;
  153.  PTOOLDAT_NumD      : Integer = 0;
  154.  
  155.  PTOOLDAT_Mon   : PTOOLDAT_Months    = ('Jan', 'Feb', 'Mar', 'Apr', 'May',
  156.                                         'Jun', 'Jul', 'Aug', 'Sep', 'Oct',
  157.                                         'Nov', 'Dec');
  158.  PTOOLDAT_Month : PTOOLDAT_Months    = ('January', 'February', 'March',
  159.                                         'April', 'May', 'June', 'July',
  160.                                         'August', 'September', 'October',
  161.                                         'November', 'December');
  162.  PTOOLDAT_Day   : PTOOLDAT_Days      = ('Sun', 'Mon', 'Tue', 'Wed', 'Thr',
  163.                                         'Fri', 'Sat');
  164.  PTOOLDAT_DayOW : PTOOLDAT_Days      = ('Sunday', 'Monday', 'Tuesday',
  165.                                         'Wednesday', 'Thursday', 'Friday',
  166.                                         'Saturday');
  167.  
  168.  
  169. { Internal Functions Begin Here ******************************************* }
  170.  
  171.  
  172. Procedure PTOOLDAT_Parse (VAR Test               : PTOOLDAT_Str_21;
  173.                           VAR Number_of_Elements : Integer);
  174.  
  175. Var
  176.    I, J, E : Byte;                             { Get elements of input }
  177.                                                { Any of the characters }
  178. Begin                                          { below may seperate    }
  179.      I := 1;                                   { the elements.         }
  180.      For E := 1 to 3 do
  181.          Begin
  182.               While (Test [I] in
  183.                           ['/', '-', ',', '.', ';', ':', '(', ')', '·', ' '])
  184.                 and (I <= Length (Test)) do
  185.                     I := I + 1;
  186.               J := 1;
  187.               While (not (Test [I] in
  188.                           ['/', '-', ',', '.', ';', ':', '(', ')', '·', ' ']))
  189.                 and (I <= Length (Test)) do
  190.                     Begin
  191.                          PTOOLDAT_Element [E] [J] := Test [I];
  192.                          J := J + 1;
  193.                          I := I + 1;
  194.                          Number_of_Elements := E;
  195.                          PTOOLDAT_Element [E] [0] := Char (J - 1);
  196.                     End;
  197.          End;
  198.      While (Test [I] in ['/', '-', ',', '.', ';', ':', '(', ')', '·', ' '])
  199.        and (I <= Length (Test)) do
  200.            I := I + 1;
  201.      If (not (Test [I] in ['/', '-', ',', '.', ';', ':', '(', ')', '·', ' ']))
  202.        and (I <= Length (Test)) then
  203.            Number_of_Elements := 4;
  204. End;
  205.  
  206.  
  207. Function PTOOLDAT_Set_Century (InYear : Integer) : Integer;
  208.  
  209. Var                                   { Add correct century based on Base }
  210.    Century : Integer;                 { Year - if less than then next     }
  211.                                       { century else same.                }
  212. Begin
  213.      Century := Trunc (Int ( PTOOLDAT_BaseYear / 100)) * 100;
  214.      If InYear >= PTOOLDAT_BaseYear - Century
  215.      then PTOOLDAT_Set_Century := Century + InYear
  216.      else PTOOLDAT_Set_Century := Century + InYear + 100;
  217. End;
  218.  
  219.  
  220. Function PTOOLDAT_GetNum (Test : PTOOLDAT_Str_21; MDY : Char) : Integer;
  221.  
  222. Var
  223.    Number    : Integer;                         { Get the number of the }
  224.    Code      : Integer;                         { Month, Day, or Year   }
  225.    I, J      : Byte;
  226.    Year      : Integer;
  227.    Century   : Integer;
  228.    Ch        : Char;
  229.    TestMon   : String [3];
  230.    TestMonth : String [9];
  231.  
  232. Begin
  233.      PTOOLDAT_GetNum := 0;
  234.      Number := 0;
  235.      Val (Test, Number, Code);
  236.      Case MDY of
  237.       'M' : If (Code = 0)
  238.            and (Number in [1..12]) then
  239.                PTOOLDAT_GetNum := Number
  240.             else
  241.                Begin
  242.                     For I := 1 to 21 do
  243.                         Begin
  244.                              Ch := Test [I];
  245.                              Test [I] := UpCase (Ch);
  246.                         End;
  247.                     For I := 1 to 12 do
  248.                         Begin
  249.                              For J := 1 to 3 do
  250.   { Check for    }               Begin
  251.   { alphabetic   }                    Ch := PTOOLDAT_Mon [I] [J];
  252.   { month inputs }                    TestMon [J] := UpCase (Ch);
  253.                                  End;
  254.                              For J := 1 to 9 do
  255.                                  Begin
  256.                                       Ch := PTOOLDAT_Month [I] [J];
  257.                                       TestMonth [J] := UpCase (Ch);
  258.                                  End;
  259.                              TestMon [0] := PTOOLDAT_Mon [I] [0];
  260.                              TestMonth [0] := PTOOLDAT_Month [I] [0];
  261.                              If (Test = TestMon)
  262.                              or (Test = TestMonth) then
  263.                                 PTOOLDAT_GetNum := I;
  264.                         End;
  265.                End;
  266.       'D' : If Code = 0 then
  267.                If Number in [1..31] then PTOOLDAT_GetNum := Number;
  268.       'Y' : If Code = 0 then
  269.                If Number > 99 then PTOOLDAT_GetNum := Number
  270.                  else
  271.                   PTOOLDAT_GetNum := PTOOLDAT_Set_Century (Number);
  272.       End; {Case}
  273. End;
  274.  
  275.  
  276. Function PTOOLDAT_Leap_Year (InYear : Integer) : Boolean;
  277.  
  278. Var                                          { Find out if it's a Leap Year }
  279.    Century : Integer;
  280.    Year    : Integer;
  281.  
  282. Begin
  283.      If InYear < 100 then
  284.         InYear := PTOOLDAT_Set_Century (InYear);
  285.      Century := Trunc (Int (InYear / 100));
  286.      Year := InYear - (Century * 100);
  287.      PTOOLDAT_Leap_Year := True;
  288.      If Year <> (Trunc (Int (Year / 4)) * 4) then PTOOLDAT_Leap_Year := False;
  289.      If (Year = 0) and
  290.         (Century = (Trunc (Int (Century / 4)) * 4)) and
  291.         (Century <> (Trunc (Int (Century / 10)) * 10)) then
  292.            PTOOLDAT_Leap_Year := False;
  293. End;
  294.  
  295.  
  296. Function PTOOLDAT_G_Check (Test : PTOOLDAT_Str_21;
  297.                            OrderIn : PTOOLDAT_Str_3)
  298.                           : Boolean;
  299.  
  300. Var                                      { Find out if the Element areas    }
  301.    Num_of_El : Integer;                  { represent a valid Gregorian date }
  302.    E         : Byte;                     { and set Number areas             }
  303.    Ok        : Boolean;
  304.  
  305. Begin
  306.      Ok := True;
  307.      PTOOLDAT_Parse (Test, Num_of_El);
  308.      If Num_of_El <> 3 then
  309.         Ok := False;
  310.      For E := 1 to 3 do
  311.          Begin
  312.               PTOOLDAT_Number [E] := PTOOLDAT_GetNum (PTOOLDAT_Element [E],
  313.                                                       OrderIn [E]);
  314.               If PTOOLDAT_Number [E] = 0 then Ok := False;
  315.          End;
  316.      If Ok = True then
  317.         Begin
  318.              For E := 1 to 3 do
  319.                  Case OrderIn [E] of
  320.                   'Y' : PTOOLDAT_NumY := PTOOLDAT_Number [E];
  321.                   'M' : PTOOLDAT_NumM := PTOOLDAT_Number [E];
  322.                   'D' : PTOOLDAT_NumD := PTOOLDAT_Number [E];
  323.                   End; {Case}
  324.              If PTOOLDAT_NumD > 30 then
  325.                 If not (PTOOLDAT_NumM in [1, 3, 5, 7, 8, 10, 12]) then
  326.                    Ok := False;
  327.              If (PTOOLDAT_NumD > 29) and
  328.                 (PTOOLDAT_NumM = 2) then Ok := False;
  329.              If (PTOOLDAT_NumD > 28) and
  330.                 (PTOOLDAT_NumM = 2) and
  331.                 (PTOOLDAT_Leap_Year (PTOOLDAT_NumY) = False) then
  332.                 Ok := False;
  333.         End;
  334.      PTOOLDAT_G_Check := Ok;
  335. End;
  336.  
  337.  
  338. Function PTOOLDAT_Make_G : PTOOLDAT_Str_21;
  339.  
  340. Var                              { Transform the Number & Element areas }
  341.    E      : Byte;                { into a Gregorian date                }
  342.    Output : String [21];
  343.  
  344. Begin
  345.      If PTOOLDAT_G_YrDisp = 2 then
  346.         Str (PTOOLDAT_NumY - (Trunc (Int (PTOOLDAT_NumY / 100)) * 100):2,
  347.              PTOOLDAT_ElY)
  348.      else
  349.         Str (PTOOLDAT_NumY:4, PTOOLDAT_ElY);
  350.      If PTOOLDAT_ElY [1] = ' ' then PTOOLDAT_ElY [1] := '0';
  351.      Case PTOOLDAT_G_MoDisp of
  352.       2 : Begin
  353.                Str (PTOOLDAT_NumM:2, PTOOLDAT_ElM);
  354.                If PTOOLDAT_ElM [1] = ' ' then
  355.                   If PTOOLDAT_G_ZeroSup then Delete (PTOOLDAT_ElM, 1, 1)
  356.                                         else PTOOLDAT_ElM [1] := '0';
  357.           End;
  358.       3 : PTOOLDAT_ElM := PTOOLDAT_Mon [PTOOLDAT_NumM];
  359.       9 : PTOOLDAT_ElM := PTOOLDAT_Month [PTOOLDAT_NumM];
  360.      End; {Case}
  361.      Str (PTOOLDAT_NumD:2, PTOOLDAT_ElD);
  362.      If PTOOLDAT_ElD [1] = ' ' then
  363.         If PTOOLDAT_G_ZeroSup then Delete (PTOOLDAT_ElD, 1, 1)
  364.                               else PTOOLDAT_ElD [1] := '0';
  365.      Output := '';
  366.      For E := 1 to 3 do
  367.          Begin
  368.               Case PTOOLDAT_G_Order [E] of
  369.                'Y' : Output := Output + PTOOLDAT_ElY;
  370.                'M' : Output := Output + PTOOLDAT_ElM;
  371.                'D' : Output := Output + PTOOLDAT_ElD;
  372.                End; {Case}
  373.               Case E of
  374.                1 : Output := Output + PTOOLDAT_G_Sep1;
  375.                2 : Output := Output + PTOOLDAT_G_Sep2;
  376.                End; {Case}
  377.          End;
  378.      PTOOLDAT_Make_G := Output;
  379. End;
  380.  
  381.  
  382. Function PTOOLDAT_G_Convert (Test  : PTOOLDAT_Str_21;
  383.                              OrderIn, OrderOut : PTOOLDAT_Str_3)
  384.                             : PTOOLDAT_Str_21;
  385.  
  386. Begin                                               { Transform date formats }
  387.      PTOOLDAT_G_Convert := ' ';
  388.      If PTOOLDAT_G_Check (Test, OrderIn) then
  389.         PTOOLDAT_G_Convert := PTOOLDAT_Make_G;
  390. End;
  391.  
  392.  
  393. Function PTOOLDAT_Day_of_Year : Integer;
  394.  
  395. Var                                           { Get Day of Year }
  396.    Result : Integer;
  397.  
  398. Const
  399.      Days : Array [1..12] of Integer = (0, 31, 59, 90, 120, 151, 181, 212,
  400.                                         243, 273, 304, 334);
  401.  
  402. Begin
  403.       Result := Days [PTOOLDAT_NumM] + PTOOLDAT_NumD;
  404.       If (PTOOLDAT_NumM > 2) and
  405.          (PTOOLDAT_Leap_Year (PTOOLDAT_NumY)) then
  406.          Result := Result + 1;
  407.       PTOOLDAT_Day_of_Year := Result;
  408. End;
  409.  
  410.  
  411. Function PTOOLDAT_J_Type_E : Real;
  412.  
  413. Var                                        { Get 'E' type Julian Date from }
  414.    Accum : Real;                           { Number area                   }
  415.    I, J  : Integer;
  416.  
  417. Begin
  418.      If PTOOLDAT_BaseYear <= PTOOLDAT_NumY then
  419.         Begin
  420.              J := Trunc ( Int((PTOOLDAT_NumY - PTOOLDAT_BaseYear) / 4));
  421.              Accum := Int (J) * 1461;
  422.              I := PTOOLDAT_BaseYear + (J * 4);
  423.              While I < PTOOLDAT_NumY do
  424.                    Begin
  425.                         If PTOOLDAT_Leap_Year (I) then Accum := Accum + 366
  426.                                                   else Accum := Accum + 365;
  427.                         I := I + 1;
  428.                   End;
  429.              PTOOLDAT_J_Type_E := Accum + PTOOLDAT_Day_of_Year - 1;
  430.         End
  431.      else
  432.         Begin
  433.              If PTOOLDAT_Leap_Year (PTOOLDAT_NumY) then
  434.                 Accum := 367 - PTOOLDAT_Day_of_Year
  435.              else
  436.                 Accum := 366 - PTOOLDAT_Day_of_Year;
  437.              J := Trunc ( Int ((PTOOLDAT_BaseYear - PTOOLDAT_NumY) / 4));
  438.              Accum := Accum + (Int (J) * 1461);
  439.              I := PTOOLDAT_NumY + 1 + (J * 4);
  440.              While I < PTOOLDAT_BaseYear do
  441.                    Begin
  442.                         If PTOOLDAT_Leap_Year (I) then Accum := Accum + 366
  443.                                                   else Accum := Accum + 365;
  444.                         I := I + 1;
  445.                    End;
  446.              PTOOLDAT_J_Type_E := Accum * -1;
  447.         End;
  448. End;
  449.  
  450.  
  451. Procedure PTOOLDAT_Set_M_D (Input : Real);
  452.  
  453. Var                                               { Get Month & Day }
  454.    InInt    : Integer;                            { from DDD        }
  455.    I        : Byte;
  456.    J        : Integer;
  457.    DayTest  : Array [1..12] of Integer;
  458.  
  459. Const
  460.      Days : Array [1..12] of Integer = (0, 31, 59, 90, 120, 151, 181, 212,
  461.                                         243, 273, 304, 334);
  462.  
  463. Begin
  464.      InInt := Trunc (Input - ((Int (Trunc (Input / 1000))) * 1000));
  465.      Move (Days, DayTest, 24);
  466.      If PTOOLDAT_Leap_Year (PTOOLDAT_NumY) then
  467.         For I := 3 to 12 do
  468.             DayTest [I] := DayTest [I] + 1;
  469.      For I := 1 to 12 do
  470.          If InInt > DayTest [I] then
  471.             Begin
  472.                  PTOOLDAT_NumM := I;
  473.                  J := DayTest [I];
  474.             End;
  475.      PTOOLDAT_NumD := InInt - J;
  476. End;
  477.  
  478.  
  479. Procedure PTOOLDAT_J_E_Eval (Input : Real);
  480.                                                 { Convert a Julian type 'E' }
  481. Var                                             { date to Number area       }
  482.    Years, Days  : Integer;
  483.    I            : Byte;
  484.    Test         : Integer;
  485.  
  486. Begin
  487.      If Input >= 0 then
  488.         Begin
  489.              Years := Trunc (Input / 1461);
  490.              Days := Trunc (Input - (Int (Years) * 1461)) + 1;
  491.              PTOOLDAT_NumY := PTOOLDAT_BaseYear;
  492.              For I := 1 to 4 do
  493.                  Begin
  494.                       If PTOOLDAT_Leap_Year (PTOOLDAT_NumY) then Test := 366
  495.                                                             else Test := 365;
  496.                       If Days > Test then
  497.                          Begin
  498.                               Days := Days - Test;
  499.                               PTOOLDAT_NumY := PTOOLDAT_NumY + 1;
  500.                          End;
  501.                  End;
  502.              PTOOLDAT_NumY := PTOOLDAT_NumY + (Years * 4);
  503.         End
  504.      else
  505.         Begin
  506.              Input := Input * -1;
  507.              Years := Trunc (Input / 1461);
  508.              Days := Trunc (Input - (Int (Years) * 1461));
  509.              PTOOLDAT_NumY := PTOOLDAT_BaseYear - 1;
  510.              For I := 1 to 4 do
  511.                  Begin
  512.                       If PTOOLDAT_Leap_Year (PTOOLDAT_NumY) then Test := 366
  513.                                                             else Test := 365;
  514.                       If Days > Test then
  515.                          Begin
  516.                               Days := Days - Test;
  517.                               PTOOLDAT_NumY := PTOOLDAT_NumY - 1;
  518.                          End;
  519.                  End;
  520.              PTOOLDAT_NumY := PTOOLDAT_NumY - (Years * 4);
  521.              If PTOOLDAT_Leap_Year (PTOOLDAT_NumY) then Days := 367 - Days
  522.                                                    else Days := 366 - Days;
  523.         End;
  524.      PTOOLDAT_Set_M_D (Days);
  525. End;
  526.  
  527.  
  528. Procedure PTOOLDAT_J_AB_Set_Y (Input : Real);     { Put Year in Number area }
  529.                                                   { From YYmmm              }
  530. Begin
  531.      PTOOLDAT_NumY := Trunc (Input / 1000);
  532.      If PTOOLDAT_NumY < 100 then
  533.         PTOOLDAT_NumY := PTOOLDAT_Set_Century (PTOOLDAT_NumY);
  534. End;
  535.  
  536.  
  537. Function PTOOLDAT_Get_Jul : Real;
  538.                                           { Get Julian Date from Number area }
  539. Begin
  540.      Case PTOOLDAT_J_Type of
  541.       'A' : PTOOLDAT_Get_Jul := (Int (PTOOLDAT_NumY) * 1000)
  542.                               - (Int (PTOOLDAT_NumY / 100) * 100000.0)
  543.                               + Int (PTOOLDAT_Day_of_Year);
  544.       'B' : PTOOLDAT_Get_Jul := (Int (PTOOLDAT_NumY) * 1000)
  545.                               + Int (PTOOLDAT_Day_of_Year);
  546.       'E' : PTOOLDAT_Get_Jul := PTOOLDAT_J_Type_E;
  547.       End; {Case}
  548. End;
  549.  
  550.  
  551. Function PTOOLDAT_Get_S : Integer;
  552.                                       { Get Short date from Number area }
  553. Var
  554.    Julian : Real;
  555.  
  556. Const
  557.      MaxJul : Real = 65532.0;
  558.  
  559. Begin
  560.      Julian := PTOOLDAT_J_Type_E;
  561.      If (Julian >= 0) and
  562.         (Julian <= MaxJul) then PTOOLDAT_Get_S := Trunc (Julian - 32765)
  563.                            else PTOOLDAT_Get_S := -32766;
  564. End;
  565.  
  566.  
  567. Function PTOOLDAT_DOW (Day : Integer) : PTOOLDAT_Str_9;
  568.  
  569. Var
  570.    Hold_DOW : PTOOLDAT_Str_9;                     { Convert 1 - 7 to day }
  571.                                                   { of week verbage      }
  572. Begin
  573.      Case PTOOLDAT_Day_Type of
  574.       1 : Begin
  575.                Str (Day:1, Hold_DOW);
  576.                PTOOLDAT_DOW := Hold_DOW;
  577.           End;
  578.       3 : PTOOLDAT_DOW := PTOOLDAT_Day [Day];
  579.       9 : PTOOLDAT_DOW := PTOOLDAT_DayOW [Day];
  580.       End; {Case}
  581. End;
  582.  
  583.  
  584. Function PTOOLDAT_Get_Date : PTOOLDAT_Str_21;
  585.  
  586. Type                                         { BIOS call to get current date }
  587.     BiosCall = Record
  588.                Ax, Bx, Cx, Dx, Bp, Si, Ds, Es, Flags : Integer;
  589.                End;
  590.  
  591. Var
  592.     BiosRec          : BiosCall;
  593.     Year, Month, Day : String [4];
  594.  
  595. Begin
  596.      With BiosRec do
  597.           Begin
  598.                Ax := $2a shl 8;
  599.           End;
  600.      MsDos (BiosRec);
  601.      With BiosRec do
  602.           Begin
  603.                Str (Cx, Year);
  604.                Str (Dx mod 256, Day);
  605.                Str (Dx shr 8, Month);
  606.           End;
  607.      PTOOLDAT_Get_Date := Year + ' ' + Month + ' ' + Day;
  608. End;
  609.  
  610.  
  611. {Called Functions Begin Here ******************************************** }
  612.  
  613.  
  614. FUNCTION PTDGValid (Test : PTOOLDAT_Str_21) : Boolean;
  615.  
  616. BEGIN
  617.  
  618.      PTDGValid := PTOOLDAT_G_Check (Test, PTOOLDAT_G_Order);
  619.  
  620. END;
  621.  
  622.  
  623. FUNCTION PTDJValid (Test : Real) : Boolean;
  624.  
  625. VAR
  626.  
  627.    Year   : Integer;
  628.    Day    : Integer;
  629.    Ok     : Boolean;
  630.  
  631. BEGIN
  632.  
  633.      Ok := True;
  634.      Case PTOOLDAT_J_Type of
  635.       'A' : If (Test < 1.0) or
  636.                (Test > 99365.0) then Ok := False;
  637.       'B' : If (Test < 1.0) or
  638.                (Test > 9999365.0) then Ok := False;
  639.       End; {Case}
  640.      PTDJValid := Ok;
  641.      If (Ok = True) and
  642.         (PTOOLDAT_J_Type <> 'E') then
  643.         Begin
  644.              Year := Trunc (Test / 1000);
  645.              Day := Trunc (Test - (Int (Year) * 1000));
  646.              If (Day > 366)
  647.              or ((Day = 366) and
  648.                  (PTOOLDAT_Leap_Year (Year) = False))
  649.              or (Day = 0) then
  650.                 PTDJValid := False;
  651.         End;
  652.  
  653. END;
  654.  
  655.  
  656. FUNCTION PTDSValid (Short : Integer) : Boolean;
  657.  
  658. BEGIN
  659.  
  660.      If Short <> -32766 then PTDSValid := True
  661.                         else PTDSValid := False
  662.  
  663. END;
  664.  
  665.  
  666. FUNCTION PTDGtoJ (Input : PTOOLDAT_Str_21) : Real;
  667.  
  668. BEGIN
  669.  
  670.      If PTOOLDAT_G_Check (Input, PTOOLDAT_G_Order) then
  671.         PTDGtoJ := PTOOLDAT_Get_Jul;
  672.  
  673. END;
  674.  
  675.  
  676. FUNCTION PTDJtoG (Input : Real) : PTOOLDAT_Str_21;
  677.  
  678. BEGIN
  679.  
  680.      PTDJtoG := ' ';
  681.      If PTOOLDAT_J_Type = 'E' then PTOOLDAT_J_E_Eval (Input)
  682.      else
  683.         Begin
  684.              PTOOLDAT_J_AB_Set_Y (Input);
  685.              PTOOLDAT_NumY := Trunc (Input / 1000);
  686.              If PTOOLDAT_NumY < 100 then
  687.                 PTOOLDAT_NumY := PTOOLDAT_Set_Century (PTOOLDAT_NumY);
  688.              PTOOLDAT_Set_M_D (Input);
  689.         End;
  690.      PTDJtoG := PTOOLDAT_Make_G;
  691.  
  692. END;
  693.  
  694.  
  695. FUNCTION PTDGtoG (Input : PTOOLDAT_Str_21) : PTOOLDAT_Str_21;
  696.  
  697. BEGIN
  698.  
  699.      If PTOOLDAT_G_Check (Input, PTOOLDAT_G2_Order) then
  700.         PTDGtoG := PTOOLDAT_Make_G
  701.      else
  702.         PTDGtoG := ' ';
  703.  
  704. END;
  705.  
  706.  
  707. FUNCTION PTDGtoS (Input : PTOOLDAT_Str_21) : Integer;
  708.  
  709. BEGIN
  710.  
  711.      If PTOOLDAT_G_Check (Input, PTOOLDAT_G_Order) then
  712.         PTDGtoS := PTOOLDAT_Get_S
  713.      else
  714.         PTDGtoS := -32766;
  715.  
  716. END;
  717.  
  718.  
  719. FUNCTION PTDStoG (Short : Integer) : PTOOLDAT_Str_21;
  720.  
  721. BEGIN
  722.  
  723.      If PTDSValid (Short) = False then PTDStoG := ' '
  724.      else
  725.         Begin
  726.              PTOOLDAT_J_E_Eval (Int (Short) + 32765);
  727.              PTDStoG := PTOOLDAT_Make_G;
  728.         End
  729.  
  730. END;
  731.  
  732.  
  733. FUNCTION PTDJtoS (Input : Real) : Integer;
  734.  
  735. CONST
  736.  
  737.      MaxJul : Real = 65532.0;
  738.  
  739. BEGIN
  740.  
  741.      PTDJtoS := -32766;
  742.      If PTOOLDAT_J_TYPE in ['A', 'B'] then
  743.         Begin
  744.              PTOOLDAT_J_AB_Set_Y (Input);
  745.              PTOOLDAT_Set_M_D (Input);
  746.              PTDJtoS := PTOOLDAT_Get_S;
  747.         End
  748.      else
  749.         If (Input >= 0) and
  750.            (Input <= MaxJul) then PTDJtoS := Trunc (Input - 32765);
  751.  
  752. END;
  753.  
  754.  
  755. FUNCTION PTDStoJ (Short : Integer) : Real;
  756.  
  757. VAR
  758.  
  759.    Julian_E : Real;
  760.  
  761. BEGIN
  762.  
  763.      Julian_E := Int (Short) + 32765;
  764.      If PTDSValid (Short) then
  765.         If PTOOLDAT_J_Type = 'E' then
  766.            PTDStoJ := Julian_E
  767.         else
  768.            Begin
  769.                 PTOOLDAT_J_E_Eval (Julian_E);
  770.                 PTDStoJ := PTOOLDAT_Get_Jul;
  771.            End;
  772.  
  773. END;
  774.  
  775.  
  776. FUNCTION PTDGAdd (Input : PTOOLDAT_Str_21;
  777.                   Number : Integer) : PTOOLDAT_Str_21;
  778.  
  779. BEGIN
  780.  
  781.      If PTOOLDAT_G_Check (Input, PTOOLDAT_G_Order) then
  782.         Begin
  783.              PTOOLDAT_J_E_Eval (PTOOLDAT_J_Type_E + Int (Number));
  784.              PTDGAdd := PTOOLDAT_Make_G;
  785.         End;
  786.  
  787. END;
  788.  
  789.  
  790. FUNCTION PTDJAdd (Input : Real; Number : Integer) : Real;
  791.  
  792. BEGIN
  793.  
  794.      If PTOOLDAT_J_Type = 'E' then
  795.         PTDJAdd := (Input + Int (Number))
  796.     else
  797.         Begin
  798.              PTOOLDAT_J_AB_Set_Y (Input);
  799.              PTOOLDAT_Set_M_D (Input);
  800.              PTOOLDAT_J_E_Eval (PTOOLDAT_J_Type_E + Int (Number));
  801.              PTDJAdd := PTOOLDAT_Get_Jul;
  802.         End;
  803.  
  804. END;
  805.  
  806.  
  807. FUNCTION PTDGComp (Minuend, Subtrahend : PTOOLDAT_Str_21) : Real;
  808.  
  809. VAR
  810.    Hold_Jul_Type : Char;
  811.  
  812. BEGIN
  813.  
  814.      Hold_Jul_Type := PTOOLDAT_J_Type;
  815.      PTOOLDAT_J_Type := 'E';
  816.      PTDGComp := PTDGtoJ (Minuend) - PTDGtoJ (Subtrahend);
  817.      PTOOLDAT_J_Type := Hold_Jul_Type;
  818.  
  819. END;
  820.  
  821. FUNCTION PTDJComp (Minuend, Subtrahend : Real) : Real;
  822.  
  823. VAR
  824.  
  825.    Hold_Jul : Real;
  826.  
  827. BEGIN
  828.  
  829.      If PTOOLDAT_J_Type = 'E' then PTDJComp := Minuend - Subtrahend
  830.      else
  831.         Begin
  832.              PTOOLDAT_J_AB_Set_Y (Minuend);
  833.              PTOOLDAT_Set_M_D (Minuend);
  834.              Hold_Jul := (PTOOLDAT_J_Type_E);
  835.              PTOOLDAT_J_AB_Set_Y (Subtrahend);
  836.              PTOOLDAT_Set_M_D (Subtrahend);
  837.              PTDJComp := Hold_Jul - (PTOOLDAT_J_Type_E);
  838.         End;
  839.  
  840. END;
  841.  
  842.  
  843. FUNCTION PTDGLeap (Input : PTOOLDAT_Str_21) : Boolean;
  844.  
  845. BEGIN
  846.  
  847.      If PTOOLDAT_G_Check (Input, PTOOLDAT_G_Order) then
  848.         PTDGLeap := PTOOLDAT_Leap_Year (PTOOLDAT_NumY)
  849.      else
  850.         PTDGLeap := False;
  851.  
  852. END;
  853.  
  854.  
  855. FUNCTION PTDJLeap (Input : Real) : Boolean;
  856.  
  857. BEGIN
  858.  
  859.      If PTOOLDAT_J_Type = 'E' then
  860.         PTOOLDAT_J_E_Eval (Input)
  861.      else
  862.         PTOOLDAT_J_AB_Set_Y (Input);
  863.      PTDJLeap := PTOOLDAT_Leap_Year (PTOOLDAT_NumY);
  864.  
  865. END;
  866.  
  867.  
  868. FUNCTION PTDSLeap (Input : Integer) : Boolean;
  869.  
  870. BEGIN
  871.  
  872.      If PTDSValid (Input) = False then PTDSLeap := False
  873.      else
  874.         Begin
  875.              PTOOLDAT_J_E_Eval (Int (Input) + 32765);
  876.              PTDSLeap := PTOOLDAT_Leap_Year (PTOOLDAT_NumY);
  877.         End;
  878.  
  879. END;
  880.  
  881.  
  882. FUNCTION PTDYLeap (Input : Integer) : Boolean;
  883.  
  884. BEGIN
  885.  
  886.      PTDYLeap := PTOOLDAT_Leap_Year (Input);
  887.  
  888. END;
  889.  
  890.  
  891. FUNCTION PTDGDay (Input : PTOOLDAT_Str_21) : PTOOLDAT_Str_9;
  892.  
  893. VAR
  894.  
  895.    Hold_Base_Year : Integer;
  896.    Hold_Jul_Type    : Char;
  897.    Day            : Integer;
  898.  
  899. BEGIN
  900.  
  901.      Hold_Base_Year := PTOOLDAT_BaseYear;
  902.      PTOOLDAT_BaseYear := 0100;
  903.      Hold_Jul_Type := PTOOLDAT_J_Type;
  904.      PTOOLDAT_J_Type := 'E';
  905.      Day := Trunc (Frac (PTDGtoJ (Input) / 7) * 7.001) + 1;
  906.      PTDGDay := PTOOLDAT_DOW (Day);
  907.      PTOOLDAT_BaseYear := Hold_Base_Year;
  908.      PTOOLDAT_J_Type := Hold_Jul_Type;
  909.  
  910. END;
  911.  
  912.  
  913. FUNCTION PTDJDay (Input : Real) : PTOOLDAT_Str_9;
  914.  
  915. BEGIN
  916.  
  917.      PTDJDay := PTDGDay (PTDJtoG (Input));
  918.  
  919. END;
  920.  
  921.  
  922. FUNCTION PTDSDay (Input : Integer) : PTOOLDAT_Str_9;
  923.  
  924. BEGIN
  925.  
  926.      PTDSDay := PTDGDay (PTDStoG (Input));
  927.  
  928. END;
  929.  
  930.  
  931. FUNCTION PTDGCurr : PTOOLDAT_Str_21;
  932.  
  933. BEGIN
  934.  
  935.      PTDGCurr := PTOOLDAT_G_Convert (PTOOLDAT_Get_Date,
  936.                                      'YMD', PTOOLDAT_G_Order);
  937.  
  938. END;
  939.  
  940.  
  941. FUNCTION PTDJCurr : Real;
  942.  
  943. BEGIN
  944.  
  945.      PTDJCurr := PTDGtoJ (PTDGCurr);
  946.  
  947. END;
  948.  
  949.  
  950. FUNCTION PTDSCurr : Integer;
  951.  
  952. BEGIN
  953.  
  954.      PTDSCurr := PTDGtoS (PTDGCurr);
  955.  
  956. END;
  957.  
  958.  
  959.  
  960. { PTOOLENT portion of PTOOL1.BOX begins here *************************** }
  961.  
  962.  
  963. Procedure PTOOLENT (VAR Data;                  { Note - Untyped           }
  964.                         TypeData   : Char;     { Must be I, R, S, G, or J }
  965.                         Size,                  { Must be 1 to 80          }
  966.                         Decimals   : Integer;  { Only for type R          }
  967.                     VAR OutEndCode : Integer); { Return Code              }
  968.  
  969.  
  970. Var
  971.  
  972.    PassI        : Integer       absolute Data;  { Initial Data               }
  973.    PassR        : Real          absolute Data;
  974.    PassS        : String [80]   absolute Data;
  975.    Ch, Ch2      : Char;                         { Keyboard Input             }
  976.    CurrS, SaveS : String [80];                  { Working Data               }
  977.    I, J         : Integer;                      { Position Pointers          }
  978.    DispX, DispY : Integer;                      { Initial Cursor Location    }
  979.    Done         : Boolean;                      { Switch for end of edit     }
  980.    ErrCode      : Integer;                      { Used for String to Numeric }
  981.    Dot          : Char;                         { Space character on screen  }
  982.    InputType    : Char;
  983.  
  984.  
  985. Const
  986.  
  987.    InsertKey : Boolean = False;                   { Insert On/Off Switch    }
  988.    PrevS     : String [80] = 'No data available'; { Holding area for Ctrl-P }
  989.  
  990.  
  991. Function PowerOf (Number, Power : Integer) : Real;  { Exponentiation Routine }
  992.  
  993.      Var
  994.         J    : Integer;
  995.         Work : Real;
  996.  
  997.      Begin
  998.           Work := Number;
  999.           For J := 1 to Power - 1 do
  1000.               Work := Work * 10;
  1001.           PowerOf := Work;
  1002.      End;
  1003.  
  1004.  
  1005. Function LowCase (Ch : Char) : Char;      { Convert Upper to Lower Case }
  1006.  
  1007.      Begin
  1008.           If Ord (Ch) in [65 .. 90] then
  1009.              LowCase := Char (Ord (Ch) + 32)
  1010.           else
  1011.              LowCase := Ch;
  1012.      End;
  1013.  
  1014.  
  1015. Procedure Beep;                   { Make a short sound }
  1016.  
  1017.      Begin
  1018.           Sound (880);
  1019.           Delay (150);
  1020.           NoSound;
  1021.      End;
  1022.  
  1023. Procedure Display;                 { Display the Current Data }
  1024.  
  1025.      Begin
  1026.           Gotoxy (DispX, DispY);
  1027.           CurrS [0] := Char(Size);
  1028.           Write (CurrS);
  1029.      End;
  1030.  
  1031. Procedure AddASpace;              { Put a Dot at the Right end of the Data }
  1032.  
  1033.      Begin
  1034.           Insert (Dot, CurrS, Size + 1);
  1035.      End;
  1036.  
  1037. Procedure LeftJustify;                  { Left Justify the data }
  1038.  
  1039.      Begin
  1040.           For J := 1 to Size do
  1041.               If CurrS [1] = Dot then
  1042.                  Begin
  1043.                       Delete (CurrS, 1, 1);
  1044.                       AddASpace;
  1045.                  End;
  1046.      End;
  1047.  
  1048. Procedure InsertSwitch;         { Turn Insert On or Off (Toggle) }
  1049.  
  1050. type
  1051.     BiosCall = Record
  1052.                Ax, Bx, Cx, Dx, Bp, Si, Ds, Es, Flags : Integer;
  1053.                End;
  1054.     XferArea = Record
  1055.                Case Boolean of
  1056.                     True  : (Lo, Hi : Byte);
  1057.                     False : (I : Integer);
  1058.                End;
  1059.  
  1060. var
  1061.     BiosRec            : BiosCall;
  1062.     XferRec            : XferArea;
  1063.  
  1064.  
  1065. Begin                                              { Begin of InsertSwitch }
  1066.      If InsertKey = True then InsertKey := False
  1067.                          else InsertKey := True;
  1068.  
  1069.      XferRec.Lo := 0;                 { This calls IBM DOS BIOS to }
  1070.      XferRec.Hi := 1;                 { alter the cursor mode.     }
  1071.      BiosRec.Ax := XferRec.I;
  1072.      XferRec.Lo := 7;
  1073.      If InsertKey = True then XferRec.Hi := 4
  1074.                          else XferRec.Hi := 6;
  1075.      BiosRec.Cx := XferRec.I;
  1076.      Intr(16, BiosRec);
  1077. End;
  1078.  
  1079.  
  1080. Label
  1081.  
  1082.      DisplayPoint;     { If there are errors in numeric data the program
  1083.                          returns to DisplayPoint.                        }
  1084.  
  1085. BEGIN                              { Begin of PTOOLENT Procedure }
  1086.  
  1087.      Dot     := Char (250);        { A Little tiny Dot }
  1088.      Done    := False;
  1089.      ErrCode := 0;
  1090.      DispX   := WhereX;
  1091.      DispY   := WhereY;
  1092.      FillChar (CurrS, Size + 1, Dot);
  1093.      InputType := TypeData;
  1094.      Case TypeData of
  1095.           'J' : TypeData := 'R';
  1096.           'G' : TypeData := 'S';
  1097.           End; {Case}
  1098.      Case TypeData of                                                { Move  }
  1099.           'I' : If PassI <> 0 then Str (PassI:Size, CurrS);          { input }
  1100.           'R' : If PassR <> 0 then Str (PassR:Size:Decimals, CurrS); { data  }
  1101.           'S' : CurrS := PassS;                                      { to    }
  1102.           End; {Case}                                                { CurrS }
  1103.      If (TypeData = 'I') or (TypeData = 'R') then    { Left Justify }
  1104.           For I := 1 to Size do                      { Numeric Data }
  1105.               If CurrS [1] = ' ' then
  1106.                  Begin
  1107.                       Delete (CurrS, 1, 1);
  1108.                       AddASpace;
  1109.                  End;
  1110.      For I := 1 to Size do
  1111.          If CurrS [I] = ' ' then CurrS [I] := Dot;
  1112.      CurrS [0] := Char (Size);
  1113.      I := 1;
  1114.      SaveS := CurrS;
  1115.   DisplayPoint:
  1116.      Display;
  1117.      While NOT Done Do                      { Main editing loop }
  1118.            Begin
  1119.                 If I < 1 then                       { Check cursor position }
  1120.                    Begin
  1121.                         I := 1;
  1122.                         Beep;
  1123.                    End;
  1124.                 If I > Size then
  1125.                    Begin
  1126.                         I := Size;
  1127.                         Beep;
  1128.                    End;
  1129.                 Gotoxy (DispX + I - 1, DispY);
  1130.                 Ch  := Char(00);                    { Get Keyboard input    }
  1131.                 Ch2 := Char(00);                    { This handles extended }
  1132.                 Read (KBD, Ch);                     { Keystrokes            }
  1133.                 If Keypressed then Read (KBD, Ch2);
  1134.                 If Ord(Ch) = 27 then                { If CH is 027 then     }
  1135.                    Case Ord(Ch2) of                 { check second part     }
  1136.        {Back Tab       }  15 : Begin
  1137.                                     I := I - 1;
  1138.                                     While ((CurrS [I] = Dot) or
  1139.                                            (CurrS [I] = '.'))
  1140.                                       and (I > 1) do
  1141.                                           I := I - 1;
  1142.                                     While (CurrS [I] <> Dot)
  1143.                                       and (CurrS [I] <> '.')
  1144.                                       and (I > 1) do
  1145.                                           I := I - 1;
  1146.                                     If (CurrS [I] = Dot) or
  1147.                                        (CurrS [I] = '.') then I := I + 1;
  1148.                                End;
  1149.        {Left Arrow     }  75 : I := I -1;
  1150.        {Right Arrow    }  77 : I := I +1;
  1151.        {Ins            }  82 : InsertSwitch;
  1152.        {Del            }  83 : Begin
  1153.                                     Delete (CurrS, I, 1);
  1154.                                     AddASpace;
  1155.                                     Display;
  1156.                                End;
  1157.        {Ctrl-LeftArrow } 115 : If I = 1 then Beep
  1158.                                         else I := 1;
  1159.        {Ctrl-RightArrow} 116 : Begin
  1160.                                     I := Size;
  1161.                                     While (CurrS [I] = Dot)
  1162.                                       and (I > 0) do
  1163.                                           I := I - 1;
  1164.                                     If I < Size then
  1165.                                        I := I + 1;
  1166.                                End;
  1167.                           else Begin
  1168.                                     Done := True;
  1169.                                     OutEndCode := Ord(Ch2);
  1170.                                End;
  1171.                         End {Case}
  1172.                     else
  1173.                    Begin                       { If not 027 the check first }
  1174.                         If Ord (Ch) = 32 then
  1175.                            Ch := Dot;            { Make space bar a dot }
  1176.                         Case Ord(Ch) of
  1177.        {Ctrl-C  End    }      3 : Begin
  1178.                                        Done := True;
  1179.                                        OutEndCode := 3;
  1180.                                   End;
  1181.        {Ctrl-D  LowCase}      4 : Begin
  1182.                                        For J := 1 to Size do
  1183.                                            CurrS [J] := LowCase (CurrS [J]);
  1184.                                        Display;
  1185.                                   End;
  1186.        {Ctrl-E  Erase  }      5 : Begin
  1187.                                        PrevS := CurrS;
  1188.                                        FillChar (CurrS [1], Size, Dot);
  1189.                                        Display;
  1190.                                        I := 1;
  1191.                                   End;
  1192.        {Ctrl-F  Fill   }      6 : Begin
  1193.                                        If I > 1 then J := I - 1
  1194.                                                 else J := 1;
  1195.                                        FillChar (CurrS [J + 1], Size - J,
  1196.                                                  CurrS [J]);
  1197.                                        Display;
  1198.                                   End;
  1199.        {Backspace      }      8 : If I > 1 then
  1200.                                      Begin
  1201.                                           Delete (CurrS, I - 1, 1);
  1202.                                           AddASpace;
  1203.                                           Display;
  1204.                                           I := I - 1;
  1205.                                      End
  1206.                                      else Beep;
  1207.        {Tab            }      9 : Begin
  1208.                                        While (CurrS [I] <> Dot)
  1209.                                          and (CurrS [I] <> '.')
  1210.                                          and (I < Size) do
  1211.                                              I := I + 1;
  1212.                                        While ((CurrS [I] = Dot) or
  1213.                                               (CurrS [I] = '.'))
  1214.                                          and (I < Size) do
  1215.                                              I := I + 1;
  1216.                                   End;
  1217.        {Ctrl-L  L-Just }     12 : Begin
  1218.                                        LeftJustify;
  1219.                                        Display;
  1220.                                        I := 1;
  1221.                                   End;
  1222.        {C/R    End     }     13 : Begin
  1223.                                        Done := True;
  1224.                                        OutEndCode := 1;
  1225.                                   End;
  1226.        {Ctrl-N  Quit   }     14 : Begin
  1227.                                        CurrS := SaveS;
  1228.                                        Done := True;
  1229.                                        OutEndCode := 1;
  1230.                                   End;
  1231.        {Ctrl-P  Prev.  }     16 : Begin
  1232.                                        For I := 1 to Size do
  1233.                                            CurrS [I] := PrevS [I];
  1234.                                        I := 1;
  1235.                                        Display;
  1236.                                   End;
  1237.        {Ctrl-Q  Quit   }     17 : Begin
  1238.                                        CurrS := SaveS;
  1239.                                        Done := True;
  1240.                                        OutEndCode := 1;
  1241.                                   End;
  1242.        {Ctrl-R  R-Just }     18 : Begin
  1243.                                        I := Size;
  1244.                                        While (CurrS [I] = Dot)
  1245.                                          and (I > 0) do
  1246.                                              I := I - 1;
  1247.                                        If I < Size then
  1248.                                           Begin
  1249.                                                J := Size - I;
  1250.                                                For I := 1 to J do
  1251.                                                    Insert (Dot, CurrS, 1);
  1252.                                           End;
  1253.                                        I := 1;
  1254.                                        While CurrS [I] = Dot do
  1255.                                              I := I + 1;
  1256.                                        Display
  1257.                                   End;
  1258.        {Ctrl-S  Restart}     19 : Begin
  1259.                                        CurrS := SaveS;
  1260.                                        I := 1;
  1261.                                        Goto DisplayPoint;
  1262.                                   End;
  1263.        {Ctrl-T  CurrDate}    20 : Begin
  1264.                                        If InputType = 'G' then
  1265.                                            CurrS := PTDGCurr
  1266.                                        else
  1267.                                           If InputType = 'J' then
  1268.                                              Str (PTDJCurr:Size:0, CurrS);
  1269.                                        Display;
  1270.                                   End;
  1271.        {Ctrl-U  UpCase }     21 : Begin
  1272.                                        For J := 1 to Size do
  1273.                                            CurrS [J] := UpCase (CurrS [J]);
  1274.                                        Display;
  1275.                                   End;
  1276.        {Ctrl-X  ClrEol }     24 : Begin
  1277.                                        FillChar (CurrS [I], Size - I + 1,
  1278.                                                  Dot);
  1279.                                        Display;
  1280.                                   End;
  1281.                         else If InsertKey = False then
  1282.                                 Begin
  1283.                                      Write (Ch);
  1284.                                      CurrS [I] := Ch;
  1285.                                      I := I + 1;
  1286.                                      If I > Size then
  1287.                                         Begin
  1288.                                              Done := True;
  1289.                                              OutEndCode := 2;
  1290.                                         End;
  1291.                                 End
  1292.                                  else
  1293.                                 Begin
  1294.                                      Insert (Ch, CurrS, I);
  1295.                                      I := I + 1;
  1296.                                      Display;
  1297.                                      If I > Size then
  1298.                                         Begin
  1299.                                              Done := True;
  1300.                                              OutEndCode := 2;
  1301.                                         End;
  1302.                                 End;
  1303.                         End; {Case}
  1304.                    End;
  1305.            End;
  1306.  
  1307.     If (TypeData = 'I')                { Left Justify Numeric data and }
  1308.     or (TypeData = 'R') then           { check for imbedded spaces     }
  1309.        Begin
  1310.             LeftJustify;
  1311.             I := 1;
  1312.             While (CurrS [I] <> Dot)
  1313.               and (I <= Size) do
  1314.                   I := I + 1;
  1315.             For J := I to Size do
  1316.                 If CurrS [J] <> Dot then
  1317.                    Begin
  1318.                         Beep;
  1319.                         I := J - 1;
  1320.                         Done := False;
  1321.                         Goto DisplayPoint;
  1322.                    End;
  1323.             CurrS [0] := Char (I - 1);
  1324.        End;
  1325.     If InsertKey = True then InsertSwitch;       { Turn off insert }
  1326.     ErrCode := 0;
  1327.     If TypeData = 'I' then
  1328.        Val (CurrS, PassI, ErrCode);
  1329.     If TypeData = 'R' then                    { Check size of Real data -    }
  1330.        Begin                                  { must leave room for decimals }
  1331.             Val (CurrS, PassR, ErrCode);
  1332.             If Decimals > 0 then
  1333.                If (PassR >= PowerOf (10, Size - Decimals - 1))
  1334.                or (PassR <= PowerOf (10, Size - Decimals - 2) * -1) then
  1335.                   Begin
  1336.                        Beep;
  1337.                        I := 1;
  1338.                        Done := False;
  1339.                        Goto DisplayPoint;
  1340.                   End;
  1341.        End;
  1342.     If ErrCode <> 0 then            { If numeric data errors, transfer }
  1343.        Begin                        { back to re-edit data.            }
  1344.             Beep;
  1345.             Done := False;
  1346.             I := ErrCode;
  1347.             Goto DisplayPoint;
  1348.        End;
  1349.     If InputType = 'J' then
  1350.        If not (PTDJValid (PassR)) then
  1351.           Begin
  1352.                Beep;
  1353.                Done := False;
  1354.                I := 1;
  1355.                Goto DisplayPoint;
  1356.           End;
  1357.     If InputType = 'G' then
  1358.        For I := 1 to Size do
  1359.            If CurrS [I] <> Dot then
  1360.               If not (PTDGValid (CurrS)) then
  1361.                  Begin
  1362.                       Beep;
  1363.                       Done := False;
  1364.                       I := 1;
  1365.                       Goto DisplayPoint;
  1366.                  End;
  1367.     If TypeData = 'S' then                    { Move String data }
  1368.        Begin
  1369.             For I := 1 to Size do
  1370.                 If CurrS [I] = Dot then CurrS [I] := ' ';
  1371.             CurrS [0] := Char (Size);
  1372.             PassS := CurrS;
  1373.        End;
  1374.     If InputType = 'G' then CurrS := PTDGtoG (CurrS);
  1375.     FillChar (PrevS, 80, Dot);                 { Save data }
  1376.     PrevS := CurrS;
  1377.     Gotoxy (DispX, DispY);                     { Display data }
  1378.     Case TypeData of
  1379.          'S' : Write (PassS);
  1380.          'I' : Write (PassI:Size);
  1381.          'R' : Write (PassR:Size:Decimals);
  1382.          End; {case}
  1383.     Gotoxy (DispX, DispY);                     { Reset cursor }
  1384.  
  1385. END;
  1386.  
  1387.  
  1388.  
  1389. { PTOOLSCR portion of PTOOL1.BOX begins here ****************************** }
  1390.  
  1391.  
  1392. TYPE
  1393.  
  1394.      PTOOLSCR_Field_Array = String [55];
  1395.  
  1396.               { Char  1    = Field Type   B = Byte             - 1 byte
  1397.                                           C = Char             - 1 byte
  1398.                                           D = Dummy            - for display
  1399.                                                                  text only
  1400.                                           M = Message          - message only
  1401.                                           I = Integer          - 2 bytes
  1402.                                           R = Real             - 6 bytes
  1403.                                           J = Real Julian Date - 6 bytes
  1404.                                           S = String  - String length
  1405.                                                         plus 1 byte
  1406.                                           G = String Gregorian Date
  1407.                 Char  2-3  = X position of display text
  1408.                 Char  4-5  = Y position of display text
  1409.                 Char  6-45 = Up to 40 characters of display text
  1410.                 Char 46-48 = 1 relative position of field in record
  1411.                 Char 49-50 = X position of field display verbage
  1412.                 Char 51-52 = Y position of field display verbage
  1413.                 Char 53-54 = Display size of field
  1414.                 Char 55    = Number of decimal places for field type R }
  1415.  
  1416.  
  1417. { Called Procedure Begins Here ******************************************** }
  1418.  
  1419.  
  1420. Procedure PTOOLSCR (VAR Record_Area,
  1421.                         Table_Area;
  1422.                         Num_Fields   : Integer;
  1423.                     VAR ReturnCode   : Integer;
  1424.                     VAR LastField    : Integer;
  1425.                         Display_Only : Char;
  1426.                         Paint_Screen : Char;
  1427.                         First_Field  : Integer);
  1428.  
  1429. VAR
  1430.  
  1431.    I             : Integer;
  1432.    RecChar       : Array [1..2] of Char                 absolute Record_Area;
  1433.    Table         : Array [1..2] of PTOOLSCR_Field_Array absolute Table_Area;
  1434.    TableHold     : PTOOLSCR_Field_Array;
  1435.  
  1436.    WorkArea      : String [80];
  1437.    WByte         : Byte         Absolute WorkArea;
  1438.    WInteger      : Integer      Absolute WorkArea;
  1439.    WReal         : Real         Absolute WorkArea;
  1440.    XorkArea      : String [80];
  1441.    XByte         : Byte         Absolute XorkArea;
  1442.    XInteger      : Integer      Absolute XorkArea;
  1443.    XReal         : Real         Absolute XorkArea;
  1444.  
  1445.    TypeData      : Char;
  1446.    DescX, DescY  : Byte;
  1447.    Desc          : String [40];
  1448.    Position      : Integer;
  1449.    DispX, DispY  : Byte;
  1450.    DispSize      : Integer;
  1451.    Decimals      : Integer;
  1452.  
  1453.    EditType      : Char;
  1454.    SpaceString   : String [80];
  1455.  
  1456.  
  1457. Procedure Set_Table (I : Integer);
  1458. Var
  1459.      TableEntry : PTOOLSCR_Field_Array;
  1460.      TableChar  : Array [1..55] of Char absolute TableEntry;
  1461.      X          : Byte;
  1462. Begin
  1463.      TableEntry := Table [I];
  1464.      TypeData   := TableChar [2];
  1465.      DescX      := ((Ord (TableChar [3]) - 48) * 10)
  1466.                   + (Ord (TableChar [4]) - 48);
  1467.      DescY      := ((Ord (TableChar [5]) - 48) * 10)
  1468.                   + (Ord (TableChar [6]) - 48);
  1469.      Move (TableChar [7], Desc [1], 40);
  1470.      X := 40;
  1471.      While (Desc [X] = ' ') and (X > 1) do
  1472.            X := X - 1;
  1473.      Desc [0]   := Char (X);
  1474.      Position   := ((Ord (TableChar [47]) - 48) * 100)
  1475.                  + ((Ord (TableChar [48]) - 48) * 10)
  1476.                  +  (Ord (TableChar [49]) - 48);
  1477.      DispX      := ((Ord (TableChar [50]) - 48) * 10)
  1478.                   + (Ord (TableChar [51]) - 48);
  1479.      DispY      := ((Ord (TableChar [52]) - 48) * 10)
  1480.                   + (Ord (TableChar [53]) - 48);
  1481.      DispSize   := ((Ord (TableChar [54]) - 48) * 10)
  1482.                   + (Ord (TableChar [55]) - 48);
  1483.      Decimals   :=  (Ord (TableChar [56]) - 48);
  1484. End;
  1485.  
  1486.  
  1487.  
  1488. BEGIN
  1489.  
  1490. For I := 1 to 80 do
  1491.     SpaceString [I] := ' ';
  1492. If Paint_Screen <> 'X' then
  1493.    For I := 1 to Num_Fields do
  1494.        Begin
  1495.             Set_Table (I);
  1496.             If (Paint_Screen <> 'N') and (Desc <> ' ') then
  1497.                Begin
  1498.                Gotoxy (DescX, DescY);
  1499.                Write  (Desc);
  1500.                End;
  1501.             If TypeData <> 'D' then
  1502.                Begin
  1503.                Move (RecChar [Position], WorkArea [0], 81);
  1504.                Gotoxy (DispX, DispY);
  1505.                Case TypeData of
  1506.                 'B' : Write (Wbyte:DispSize);
  1507.                 'C' : Write (RecChar [Position]);
  1508.                 'I' : Write (WInteger:DispSize);
  1509.            'J', 'R' : Write (WReal:DispSize:Decimals);
  1510.                 'M' : Begin
  1511.                       SpaceString [0] := Char (DispSize);
  1512.                       Write (SpaceString);
  1513.                       Gotoxy (DispX, DispY);
  1514.                       Write (WorkArea);
  1515.                       End;
  1516.            'G', 'S' : Write (WorkArea);
  1517.                 End; {Case}
  1518.                End;
  1519.        End;
  1520. If not (Display_Only in ['D', 'M']) then
  1521.    Begin
  1522.    I := First_Field;
  1523.    While I <= Num_Fields do
  1524.          Begin
  1525.          Set_Table (I);
  1526.          If TypeData in ['D', 'M'] then
  1527.             I := I + 1
  1528.          else
  1529.             Begin
  1530.             Move (RecChar [Position], WorkArea [0], 81);
  1531.             Gotoxy (DispX, DispY);
  1532.             EditType := TypeData;
  1533.             Case TypeData of
  1534.              'B' : Begin
  1535.                    EditType := 'I';
  1536.                    XInteger := WByte;
  1537.                    End;
  1538.              'C' : Begin
  1539.                    XorkArea [1] := RecChar [Position];
  1540.                    XorkArea [0] := Char (1);
  1541.                    EditType     := 'S';
  1542.                    End;
  1543.              'I' : Xinteger := WInteger;
  1544.         'J', 'R' : XReal    := WReal;
  1545.         'G', 'S' : XorkArea := WorkArea;
  1546.              End; {Case}
  1547.             PTOOLENT (XorkArea,
  1548.                       EditType,
  1549.                       DispSize,
  1550.                       Decimals,
  1551.                       ReturnCode);
  1552.             LastField := I;
  1553.             Case TypeData of
  1554.              'B' : Begin
  1555.                    WByte := XInteger;
  1556.                    Move (WByte, RecChar [Position], 1);
  1557.                    End;
  1558.              'C' : Move (XorkArea [1], RecChar [Position], 1);
  1559.              'I' : Move (XorkArea, RecChar [Position], 2);
  1560.         'J', 'R' : Move (XorkArea, RecChar [Position], 6);
  1561.         'G', 'S' : Move (XorkArea, RecChar [Position],
  1562.                          Ord (XorkArea [0]) + 1);
  1563.              End; {Case}
  1564.             Case ReturnCode of
  1565.               1, 2, 80 : Begin
  1566.                          I := I + 1;
  1567.                          ReturnCode := 1;
  1568.                          End;
  1569.               71       : I := 1;
  1570.               72       : Begin
  1571.                          I := I - 1;
  1572.                          TableHold := Table [I];
  1573.                          While (I >= 1) and (TableHold [1] in ['D', 'M']) do
  1574.                                Begin
  1575.                                I := I - 1;
  1576.                                TableHold := Table [I];
  1577.                                End;
  1578.                          If I <= 0 then I := 1;
  1579.                          End;
  1580.                79      : Begin
  1581.                          I := Num_Fields;
  1582.                          TableHold := Table [I];
  1583.                          While (I >= 1) and (TableHold [1] in ['D', 'M']) do
  1584.                                Begin
  1585.                                I := I - 1;
  1586.                                TableHold := Table [I];
  1587.                                End;
  1588.                          If I <= 0 then I := 1;
  1589.                          End;
  1590.                else      I := Num_Fields + 1;
  1591.             End; {Case}
  1592.             End;
  1593.          End;
  1594.    End;
  1595.  
  1596. END;